home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / pp.emc < prev    next >
Lisp/Scheme  |  1992-07-02  |  3KB  |  97 lines
  1. #include "mp_arith.h"
  2. #include "mp_type.h"
  3.  
  4. (defmodule pp (standard0 ppl plural) ()
  5.  
  6.   (format t "\nThis module has no plural space conservation tweaks!\n")
  7.  
  8.   (setq global-field (make-paralation 512))    
  9.  
  10.   (setq base-context (car (contexts global-field)))
  11.   (setq base-offset  (car (contexts global-field)))
  12.  
  13.   (defun list-shift-distances (config)
  14.     (if (eq config 1) ()
  15.       (cons (/ config 2) (list-shift-distances (/ config 2)))))
  16.  
  17.   (setq shifts (mapcar (lambda (n) (car (offsets (elwise ((i global-field))
  18.                            (let ((get-from (+ i n)))
  19.                              (if (< get-from 512)
  20.                                (cons get-from ()) 
  21.                                ()))))))
  22.                (reverse (list-shift-distances 512))))
  23.  
  24.   (defun ll-vref (context offset shifter combiner)
  25.     (let ((shifter (mp-assign context (mp-make-plural base-context) shifter))
  26.       (ofst-p (mp-assign context (mp-make-plural base-context) offset))
  27.       (data (mp-make-plural context))
  28.       (tive (mp-make-plural context)))
  29.       (mp-move base-context ofst-p context shifter data)
  30.       (mp-move base-context (mp-assign context (mp-make-plural base-context)
  31.                        (mp-bang context t))
  32.            context shifter tive)
  33.       (mp-if context (mp-test context tive MP_CONS))
  34.       (mp-assign context tive (mp-car context tive))
  35.       (mp-if context tive)
  36. ;(format t "offset: ~a\n" (allocate-xec context offset))
  37. ;(format t "data (~a): ~a\n" data (allocate-xec context (mp-car context data)))
  38.       (mp-assign context offset (combiner offset (mp-car context data)))
  39. ;(format t "offset: ~a\n" (allocate-xec context offset))
  40.       (mp-fi context)
  41.       (mp-fi context)
  42.       offset))
  43.   
  44.   (defun l-vref (context offset combiner)
  45.     (let ((offset (mp-assign context (mp-make-plural context) offset)))
  46.       (labels ((recurse (shifts)
  47.          (ll-vref context offset (car shifts) combiner)
  48.          (if (null (cdr shifts)) offset
  49.            (recurse (cdr shifts)))))
  50.     (recurse shifts)
  51.     (mp-ref context offset 0))))
  52.  
  53.   (defun s-vref (l with)
  54.     (if (null (cdr l)) (car l)
  55.       (with (car l) (s-vref (cdr l) with))))
  56.  
  57.   (defmacro vref (f with)
  58.     `(s-vref (mapcar (lambda (c o) 
  59.                (Set-The-Context c)
  60.                (l-vref c o ,(rewire with)))
  61.              (contexts ,f) (offsets ,f)) ,with))
  62.   
  63.   (defun ll-scan (context offset combiner)
  64.     (let ((offset (mp-assign context (mp-make-plural context) offset)))
  65.       (labels ((recurse (shifts)
  66.          (ll-vref context offset (car shifts) combiner)
  67.          (if (null (cdr shifts)) offset
  68.            (recurse (cdr shifts)))))
  69.     (recurse shifts)
  70.     offset)))
  71.  
  72.   (defun l-scan (l with)
  73.     (if (null (cdr l)) l
  74.       (let ((rest (l-scan (cdr l) with)))
  75.     (cons (with (car l) (car rest)) rest))))
  76.  
  77.   (defmacro scan (f with)
  78.     `(let* ((result (make-field (paralation ,f) 
  79.                 (mapcar mp-make-plural (contexts ,f))))
  80.         (tmp-pspace (mp-ps-ref)))
  81.        (mapcar (lambda (c o r)
  82.          (Set-The-Context c)
  83.          (mp-assign c r (ll-scan c o ,(rewire with))))
  84.            (contexts ,f) (offsets ,f) (offsets result))
  85.        (mapcar (lambda (v c o)
  86.          (Set-The-Context c)
  87.          (mp-assign c o (,(rewire with) o (mp-bang c v))))
  88.            (cdr (l-scan (mapcar (lambda (c o) (mp-ref c o 0))
  89.                     (contexts ,f) (offsets result)) ,with))
  90.            (contexts ,f) (offsets result))
  91.        result))
  92.  
  93. (export scan vref s-vref l-vref ll-scan l-scan)
  94.  
  95. )
  96.  
  97.